home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 6_2008-2009.ISO / data / zips / EGL_PointC215941872009.psc / PointCloud V1.1 / clsFilePOINTS.cls < prev    next >
Text File  |  2009-08-06  |  7KB  |  241 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "clsFilePOINTS"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Option Explicit
  15.  
  16. Private Const PrevNum As Byte = 99
  17.  
  18. Dim hFile           As Long
  19. Private DelimChar   As String
  20. Private Lines()     As String
  21.  
  22. Public Function InputList(FileName As String, lstIn As ListBox)
  23.  
  24.     Dim idx As Byte
  25.     lstIn.Clear
  26.     ReDim Lines(PrevNum)
  27.     hFile = FreeFile
  28.     Open FileName For Binary As #hFile
  29.         For idx = 0 To PrevNum
  30.             Lines(idx) = ReadString
  31.             lstIn.AddItem Lines(idx)
  32.         Next
  33.     Close #hFile
  34.  
  35. End Function
  36.  
  37. Private Function ReadString() As String
  38.  
  39.     Dim TempChar    As String
  40.     Dim TempString  As String
  41.     
  42.     TempChar = StrConv(InputB(1, #hFile), vbUnicode)
  43.     While TempChar <> vbLf
  44.         TempString = TempString & TempChar
  45.         TempChar = StrConv(InputB(1, #hFile), vbUnicode)
  46.     Wend
  47.     ReadString = Left$(TempString, Len(TempString) - 1)
  48.  
  49. End Function
  50.  
  51. Public Sub RefreshOutputList(lstOut As ListBox)
  52.     
  53.     Dim idx As Byte
  54.     Dim Lines2()     As String
  55.    
  56.     If UBound(Lines) < 1 Then Exit Sub
  57.     Lines2 = Lines
  58.     lstOut.Clear
  59.     For idx = 0 To PrevNum
  60.         lstOut.AddItem Parse(Lines2(idx))
  61.     Next
  62.         
  63. End Sub
  64.  
  65. Private Function Parse(inLine As String, Optional Preview As Boolean = True) As String
  66.     
  67.     
  68.     Dim charpos     As Long
  69.     Dim test        As String
  70.     Dim FormatLine  As String
  71.     Dim SplitLine() As String
  72.     Dim NumSplitLine As Byte
  73.     
  74.     On Error Resume Next
  75. 'Replace delimiter chars to comma
  76.     If delim.tTab Then inLine = Replace(inLine, vbTab, "|")
  77.     If delim.tSemicolon Then inLine = Replace(inLine, ";", "|")
  78.     If delim.tComma Then inLine = Replace(inLine, ",", "|")
  79.     If delim.tSpace Then inLine = Replace(inLine, " ", "|")
  80.     If delim.tOther Then inLine = Replace(inLine, delim.tDelimChar, "|")
  81. 'Eliminate double comma
  82.     Do
  83.         charpos = InStr(1, inLine, "||")
  84.         inLine = Replace(inLine, "||", "|")
  85.     Loop Until charpos = 0
  86.     
  87. 'Delete first and end char comma
  88.     test = Left$(inLine, 1)
  89.     If test = "|" Then inLine = Right$(inLine, Len(inLine) - 1)
  90.     test = Right$(inLine, 1)
  91.     If test = "|" Then inLine = Left$(inLine, Len(inLine) - 1)
  92.     
  93.     SplitLine = Split(inLine, "|")
  94.     NumSplitLine = UBound(SplitLine)
  95.     
  96. 'Format
  97.     If Preview Then
  98.         Select Case delim.tFormat
  99.             Case 0  '"X , Y , Z"
  100.                 If NumSplitLine = 2 Then
  101.                     inLine = "X: " & SplitLine(0) & "   Y: " & SplitLine(1) & "   Z: " & SplitLine(2)
  102.                 Else
  103.                     inLine = "Error line"
  104.                 End If
  105.             Case 1  '"Number , X , Y , Z"
  106.                 If NumSplitLine = 3 Then
  107.                     inLine = "N: " & SplitLine(0) & "   X: " & SplitLine(1) & "   Y: " & SplitLine(2) & "   Z: " & SplitLine(3)
  108.                 Else
  109.                     inLine = "Error line"
  110.                 End If
  111.             Case 2  '"X , Y , Z , Description"
  112.                 If NumSplitLine = 3 Then
  113.                     inLine = "X: " & SplitLine(0) & "   Y: " & SplitLine(1) & "   Z: " & SplitLine(2) & "   D: " & SplitLine(3)
  114.                 Else
  115.                     inLine = "Error line"
  116.                 End If
  117.             Case 3  '"Number , X , Y , Z , Description"
  118.                 If NumSplitLine = 4 Then
  119.                     inLine = "N: " & SplitLine(0) & "   X: " & SplitLine(1) & "   Y: " & SplitLine(2) & "   Z: " & SplitLine(3) & "   D: " & SplitLine(4)
  120.                 Else
  121.                     inLine = "Error line"
  122.                 End If
  123.         End Select
  124.     Else
  125.         Select Case delim.tFormat
  126.             Case 0, 2 '"X , Y , Z" or "X , Y , Z , Description"
  127.                     inLine = SplitLine(0) & "|" & SplitLine(1) & "|" & SplitLine(2)
  128.             Case 1, 3 '"Number , X , Y , Z" or "Number , X , Y , Z , Description"
  129.                     inLine = SplitLine(1) & "|" & SplitLine(2) & "|" & SplitLine(3)
  130.         End Select
  131.     End If
  132.     Parse = inLine
  133.  
  134. End Function
  135.  
  136. Public Sub InputAll(FileName As String)
  137.     
  138.     Dim strData As String
  139.     Dim idx     As Long
  140.     Dim dx      As Single
  141.     Dim dy      As Single
  142. '    Dim dmax    As Single
  143.     
  144.     On Error Resume Next
  145.     
  146.     'Reset
  147.     LoadComplete = False
  148.     Erase Lines
  149.     Mesh1.NumMeshs = 0
  150.     Mesh1.NumVertices = 0
  151.     Erase Mesh1.Meshs
  152.     Erase Mesh1.Vertices
  153.     
  154.     hFile = FreeFile
  155.     Open FileName For Input As #hFile
  156.         strData = Input(LOF(1) - 1, #hFile)
  157.     Close #hFile
  158.     Lines = Split(strData, vbLf)
  159.     
  160.     For idx = 0 To UBound(Lines)
  161.         Lines(idx) = Parse(Lines(idx), False)
  162.     Next
  163.  
  164.     With Dots1
  165.         .NumDot = UBound(Lines) + 1
  166.         Mesh1.NumVertices = .NumDot
  167.         ReDim .Dots(1 To .NumDot)
  168.         ReDim Mesh1.Vertices(1 To .NumDot)
  169.         
  170.         For idx = 1 To .NumDot
  171.             Mesh1.Vertices(idx) = GetVectorValue(Lines(idx - 1))
  172.             .Dots(idx).Vector = Mesh1.Vertices(idx)
  173.             .Dots(idx).Visible = True
  174.         Next idx
  175.         Erase Lines
  176.         Call CalculateBox(.Dots, .Box, .Center)
  177.         
  178. 'move center
  179.         For idx = 1 To .NumDot
  180.             .Dots(idx).Vector = VectorSubtract(.Dots(idx).Vector, .Center.Vector)
  181.         Next idx
  182.         
  183.         For idx = 1 To 8
  184.             .Box(idx).Vector = VectorSubtract(.Box(idx).Vector, .Center.Vector)
  185.         Next idx
  186.         
  187.         .Center.Vector = VectorSet(0, 0, 0)
  188.         
  189. 'scale screen
  190.         dx = .Box(7).Vector.X - .Box(1).Vector.X
  191.         dy = .Box(7).Vector.Y - .Box(1).Vector.Y
  192.         If dx > dy Then
  193.             MaxH = dx
  194.         Else
  195.             MaxH = dy
  196.         End If
  197.         
  198.         Position.Sca = (cHeight / MaxH) * 0.9 ' 0.9 bigness 90%
  199.         
  200.         For idx = 1 To .NumDot
  201.             .Dots(idx).Vector = VectorSca(.Dots(idx).Vector, Position.Sca)
  202.         Next idx
  203.         For idx = 1 To 8
  204.             .Box(idx).Vector = VectorSca(.Box(idx).Vector, Position.Sca)
  205.         Next idx
  206.         .ClpZ = (.Box(7).Vector.Z - .Box(1).Vector.Z) \ 100
  207.         
  208.     End With
  209.     Call ResetMeshParameters
  210. '    Call ResetCameraParameters
  211. '    Call ResetLightParameters
  212.     LoadComplete = True
  213.  
  214. End Sub
  215.  
  216. Private Function GetVectorValue(Line As String) As VECTOR4
  217.  
  218.     Dim Value As String
  219.     Dim Segments() As String
  220.     
  221.     Segments = Split(Line, "|")
  222.     
  223. 'X Value
  224.     Value = Segments(UBound(Segments) - 2)
  225.     GetVectorValue.X = CSng(Replace(Value, ".", ","))
  226. 'Y Value
  227.     Value = Segments(UBound(Segments) - 1)
  228.     GetVectorValue.Y = CSng(Replace(Value, ".", ","))
  229. 'Z Value
  230.     Value = Segments(UBound(Segments))
  231.     GetVectorValue.Z = CSng(Replace(Value, ".", ","))
  232. 'W Value
  233.     GetVectorValue.W = 1
  234.  
  235. End Function
  236.  
  237. Private Sub Class_Initialize()
  238.     ReDim Lines(0)
  239. End Sub
  240.  
  241.